home *** CD-ROM | disk | FTP | other *** search
/ Image Compendium / Image Compendium.iso / viewer / dos / gifdoc.arc / PANGIF.PAS < prev    next >
Encoding:
Pascal/Delphi Source File  |  1988-07-24  |  7.0 KB  |  272 lines
  1. {$R-,I-}
  2. Program panGIF;
  3. uses CRT,Dos,GRAPH,DEGIF;
  4.  
  5.   type
  6.     row = array [0..1023] of byte;
  7.     rowPtr = ^row;
  8.  
  9. var  InFileName:string;   BlockType:char;
  10.      I,NewBottom,NewLeft,NewRight,NewTop,
  11.      OffLeft,OffTop,Pass,XCord,YCord:integer;
  12.      InFile:File;
  13.      Buffer:array[0..32767] of byte;
  14.      BufIndx,Count:word;
  15.      Done,EOFin,SkipIt,Smash,Squeeze:Boolean;
  16.      image: array [0..1023] of rowPtr;
  17.      scale: longint;
  18.      xadj,yadj: array [0..1023] of integer;
  19.      white: byte;
  20.      scaleHeight,scaleWidth: integer;
  21.  
  22. procedure quit;
  23.  begin
  24.    textmode(lastmode);
  25.    halt;
  26.  end;
  27.  
  28. procedure Abort;
  29.  begin
  30.   close(InFile);Quit
  31.  end;
  32.  
  33. {$F+}
  34. function GetByte: byte;
  35. begin
  36.  if not Done
  37.   then begin
  38.         if BufIndx >= Count
  39.          then begin
  40.                Done:=EOFIn;BlockRead(InFile,Buffer,SizeOf(Buffer),Count);
  41.                EOFIn:=Count < sizeof(Buffer); BufIndx:=0
  42.               end;
  43.         GetByte:=Buffer[BufIndx]; Inc(BufIndx)
  44.        end
  45.   else GetByte:=0
  46. end;
  47. {$F-}
  48.  
  49. {$F+}
  50. procedure PutByte(Pix: integer);
  51. const YInc:array [1..5] of integer=(8,8,4,2,1);
  52.       YLin:array [1..5] of integer=(0,4,2,1,0);
  53. var x,y:integer;
  54. begin
  55.  x:=xadj[xCord];
  56.  y:=yadj[yCord];
  57.  if (x<320) and (y<200) then
  58.    mem[$A000:word(320*y+x)]:=Pix;
  59.  image[y]^[x]:=Pix;
  60.  Inc(XCord);
  61.  if XCord = NewRight
  62.   then begin XCord:=NewLeft;
  63.              if KeyPressed then Abort;
  64.              Inc(YCord,YInc[Pass]);
  65.              SkipIt:=Smash and ((YCord and 1)=1);
  66.              if YCord >= NewBottom then
  67.                begin
  68.                  if Interlaced then Inc(Pass);
  69.                  YCord:=YLin[Pass]+NewTop
  70.                end;
  71.        end
  72. end;
  73. {$F-}
  74.  
  75. procedure DoMapping;
  76.     var
  77.       i: integer;
  78.       regs: registers;
  79.       r,g,b: byte;
  80.       temp,max: longint;
  81.  begin
  82.     max:=0;
  83.     for i:=0 to NumberOfColors[CurMap]-1 do
  84.       begin
  85.         temp:=Sqr(Longint(redvalue[i]))+Sqr(Longint(greenvalue[i]))+Sqr(Longint(bluevalue[i]));
  86.         if temp>max then
  87.           begin max:=temp; white:=i; end;
  88.         r:=redvalue[i] div 4;
  89.         g:=greenvalue[i] div 4;
  90.         b:=bluevalue[i] div 4;
  91.         Inline($B8/$10/$10/$8B/$9E/>I/$8A/$B6/>R/$8A/$AE/>G/$8A/$8E/>B/$CD/$10);
  92.       end;
  93.  end;
  94.  
  95. procedure AdjustImage;
  96.   var i: integer;
  97.  begin
  98.   NewLeft  := ImageLeft + OffLeft;
  99.   NewTop   := ImageTop + OffTop;
  100.   NewRight := ImageWidth + NewLeft;
  101.   NewBottom:= ImageHeight + NewTop;
  102.   XCord:=NewLeft;   YCord:=NewTop;
  103.   if Interlaced then Pass:=1 else Pass:=5;
  104.   scale:=1024;
  105.   while MemAvail*15 div 16<(scale*imageWidth div 1024)*(scale*imageHeight div 1024) do
  106.     Dec(scale);
  107.   for i:=0 to ImageWidth-1 do
  108.     xadj[i]:=scale*i div 1024;
  109.   for i:=0 to ImageHeight-1 do
  110.     yadj[i]:=scale*i div 1024;
  111.   scaleHeight:=scale*ImageHeight div 1024;
  112.   scaleWidth:=scale*ImageWidth div 1024;
  113.   for i:=0 to scaleHeight-1 do
  114.     GetMem(image[i],scaleWidth);
  115.  end;
  116.  
  117. procedure DisplayScrDes;
  118. var I:integer;
  119.     AnsCh:char;
  120. begin
  121.  Writeln(ScreenWidth,'x',ScreenHeight,'  ',NumberOfColors[Global],' colors');
  122.  OffLeft:=0; OffTop:=0;
  123.  Smash:=false; Squeeze:=false;
  124.  end;
  125.  
  126.   procedure GraphColorMode;
  127.   begin { procedure GraphColorMode }
  128.     inline($B8/$13/$00/$CD/$10);
  129.     DoMapping;
  130.   end; { procedure GraphColorMode }
  131.  
  132.   procedure pan;
  133.     var
  134.       done: boolean;
  135.       ch: char;
  136.       x,y: integer;
  137.  
  138.     procedure slideRight;
  139.       var h,v,b: word; x0: integer;
  140.     begin { procedure slideRight }
  141.       if x=0 then exit;
  142.       x0:=x;
  143.       Dec(x,10); if x<0 then x:=0;
  144.       for v:=0 to 199 do
  145.         begin
  146.           b:=word(320*v);
  147.           Move(mem[$A000:b],mem[$A000:b+x0-x],320+x-x0);
  148.           Move(image[y+v]^[x],mem[$A000:b],x0-x);
  149.         end;
  150.     end; { procedure slideRight }
  151.  
  152.     procedure slideLeft;
  153.       var h,v,b: word; x0: integer;
  154.     begin { procedure slideLeft }
  155.       if x=scaleWidth-320 then exit;
  156.       x0:=x;
  157.       Inc(x,10); if x+320>scaleWidth then x:=scaleWidth-320;
  158.       for v:=0 to 199 do
  159.         begin
  160.           b:=word(320*v);
  161.           Move(mem[$A000:b+x-x0],mem[$A000:b],320+x0-x);
  162.           Move(image[y+v]^[320+x0],mem[$A000:b+320+x0-x],x-x0);
  163.         end;
  164.     end; { procedure slideLeft }
  165.  
  166.     procedure slideDown;
  167.       var h,v,b: word; y0: integer;
  168.     begin { procedure slideDown }
  169.       if y=0 then exit;
  170.       y0:=y;
  171.       Dec(y,10); if y<0 then y:=0;
  172.       Move(mem[$a000:0],mem[$a000:320*(y0-y)],word(320*(200+y-y0)));
  173.       for v:=0 to y0-y-1 do
  174.         begin
  175.           b:=word(320*v);
  176.           Move(image[y+v]^[x],mem[$A000:b],320);
  177.         end;
  178.     end; { procedure slideDown }
  179.  
  180.     procedure slideUp;
  181.       var h,v,b: word; y0: integer;
  182.     begin { procedure slideUp }
  183.       if y=scaleHeight-200 then exit;
  184.       y0:=y;
  185.       Inc(y,10); if y+200>scaleHeight then y:=scaleHeight-200;
  186.       Move(mem[$A000:320*(y-y0)],mem[$A000:0],word(320*(200+y0-y)));
  187.       for v:=200+y0-y to 199 do
  188.         begin
  189.           b:=word(320*v);
  190.           Move(image[y+v]^[x],mem[$A000:b],320);
  191.         end;
  192.     end; { procedure slideUp }
  193.  
  194.   begin { procedure pan }
  195.     x:=0; y:=0; done:=false;
  196.     repeat
  197.       ch:=readkey;
  198.       if ch=#0 then
  199.         case readkey of
  200.           #75: if scaleWidth>320 then slideRight;
  201.           #77: if scaleWidth>320 then slideLeft;
  202.           #72: if scaleHeight>200 then slideDown;
  203.           #80: if scaleHeight>200 then slideUp;
  204.         end
  205.       else
  206.         case ch of
  207.           #27: done:=True;
  208.         end;
  209.     until done;
  210.   end; { procedure pan }
  211.  
  212. begin
  213.  AddrGetByte:=@GetByte;
  214.  AddrPutByte:=@PutByte;
  215.  AssignCrt(output);Rewrite(OUTPUT);
  216.  if paramcount=0
  217.   then begin
  218.         write('Enter GIF file name:  '); readln(infilename);
  219.        end
  220.   else InFileName:=paramstr(1);
  221.  if length(InFileName)>0 then
  222.   begin
  223.    if pos('.',infilename)=0 then infilename:=infilename+'.gif';
  224.    assign(InFile,InFileName);
  225.    {$I-}
  226.    reset(InFile,1);
  227.    if ioresult<>0
  228.     then begin writeln('GIF datafile could not be found.'); halt; end;
  229.    SkipIt:=false;
  230.    EOFin:=false;
  231.    Done:=false;
  232.    BufIndx:=999;Count:=0;
  233.    CurMap:=Global;
  234.    GetGIFSig;
  235.    if GIFSig<>'GIF87a' then
  236.      begin
  237.        BufIndx:=128;
  238.        GetGIFSig;
  239.        if GIFSig<>'GIF87a' then
  240.          begin
  241.            writeln('Invalid GIF signature');
  242.            Halt;
  243.          end;
  244.      end;
  245.    GetScrDes;
  246.    DisplayScrDes;
  247.    if MapExists[Global] then GetColorMap;
  248.    writeln('Press <Enter> to display and wait for beep');
  249.    writeln('before scrolling image with arrow keys');
  250.    readln;
  251.    GraphColorMode;
  252.    while not Done Do
  253.     begin
  254.      BlockType:=chr(GetByte);
  255.      case BlockType of
  256.       ',':begin
  257.            GetImageDescription;
  258.            AdjustImage;
  259.            if MapExists[Local]
  260.             then begin CurMap:=Local; GetColorMap; DoMapping end
  261.             else CurMap:=Global;
  262.            if ExpandGIF <>0 then Halt
  263.           end;
  264.       '!':SkipExtendBlock;
  265.      end;
  266.     end;
  267.   end;
  268.  Sound(1000);Delay(100);NoSound;
  269.  pan;
  270.  textmode(lastmode);
  271. end.
  272.